Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/src-16f.lha/compiler/generic/interr.lisp

Text File | 1992-05-21 | 4.8 KB | 156 lines

;;; -*- Package: KERNEL -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or [e-mail].
;;;
(ext:file-comment
  "$Header: interr.lisp,v 1.2 92/03/22 17:30:26 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file defines all of the internal errors.  How they are handled is
;;; defined in .../code/interr.lisp.  How they are signaled depends on the
;;; machine.
;;;
;;; Written by William Lott.
;;;
(in-package "KERNEL")

(export '(error-number-or-lose))


(defun error-number-or-lose (name)
  (or (position name (c:backend-internal-errors c:*backend*) :key #'car)
      (error "Unknown internal error: ~S" name)))


(eval-when (compile eval)

(defmacro define-internal-errors (&rest errors)
  (let ((info (mapcar #'(lambda (x)
              (if x
                  (cons (symbolicate (first x) "-ERROR")
                    (second x))
                  '(nil . "unused")))
              errors)))
    `(progn
       (export ',(remove nil (mapcar #'car info)))
       (setf (c:backend-internal-errors c:*target-backend*)
         ',(coerce info 'vector))
       nil)))

); eval-when


(define-internal-errors
  (unknown
   "Unknown.  System lossage.")
  (object-not-function
   "Object is not of type FUNCTION.")
  (object-not-list
   "Object is not of type LIST.")
  (object-not-bignum
   "Object is not of type BIGNUM.")
  (object-not-ratio
   "Object is not of type RATIO.")
  (object-not-single-float
   "Object is not of type SINGLE-FLOAT.")
  (object-not-double-float
   "Object is not of type DOUBLE-FLOAT.")
  (object-not-simple-string
   "Object is not of type SIMPLE-STRING.")
  (object-not-simple-bit-vector
   "Object is not of type SIMPLE-BIT-VECTOR.")
  (object-not-simple-vector
   "Object is not of type SIMPLE-VECTOR.")
  (object-not-fixnum
   "Object is not of type FIXNUM.")
  (object-not-function-or-symbol
   "Object is not of type FUNCTION or SYMBOL.")
  (object-not-vector
   "Object is not of type VECTOR.")
  (object-not-string
   "Object is not of type STRING.")
  (object-not-bit-vector
   "Object is not of type BIT-VECTOR.")
  (object-not-array
   "Object is not of type ARRAY.")
  (object-not-number
   "Object is not of type NUMBER.")
  (object-not-rational
   "Object is not of type RATIONAL.")
  (object-not-float
   "Object is not of type FLOAT.")
  (object-not-real
   "Object is not of type REAL.")
  (object-not-integer
   "Object is not of type INTEGER.")
  (object-not-cons
   "Object is not of type CONS.")
  (object-not-symbol
   "Object is not of type SYMBOL.")
  (undefined-symbol
   "Undefined symbol.")
  (object-not-coercable-to-function
   "Object is not coercable to type FUNCTION.")
  (invalid-argument-count
   "Invalid argument count.")
  (bogus-argument-to-values-list
   "Bogus argument to VALUES-LIST.")
  (unbound-symbol
   "Unbound symbol.")
  nil
  (object-not-sap
   "Object is not a System Area Pointer (SAP).")
  (invalid-unwind
   "Attempt to RETURN-FROM a block that no longer exists.")
  (unseen-throw-tag
   "Attempt to THROW to a non-existent tag.")
  (division-by-zero
   "Attempt to divide by zero.")
  (object-not-type
   "Object is of the wrong type.")
  (odd-keyword-arguments
   "Odd number of keyword arguments.")
  (unknown-keyword-argument
   "Unknown keyword.")
  nil
  nil
  (invalid-array-index
   "Invalid array index.")
  (wrong-number-of-indices
   "Wrong number of indices.")
  (object-not-simple-array
   "Object is not of type SIMPLE-ARRAY.")
  (object-not-signed-byte-32
   "Object is not of type (SIGNED-BYTE 32).")
  (object-not-unsigned-byte-32
   "Object is not of type (UNSIGNED-BYTE 32).")
  (object-not-simple-array-unsigned-byte-2
   "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 2) (*)).")
  (object-not-simple-array-unsigned-byte-4
   "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 4) (*)).")
  (object-not-simple-array-unsigned-byte-8
   "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).")
  (object-not-simple-array-unsigned-byte-16
   "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (*)).")
  (object-not-simple-array-unsigned-byte-32
   "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*)).")
  (object-not-simple-array-single-float
   "Object is not of type (SIMPLE-ARRAY SINGLE-FLOAT (*)).")
  (object-not-simple-array-double-float
   "Object is not of type (SIMPLE-ARRAY DOUBLE-FLOAT (*)).")
  (object-not-complex
   "Object is not of type COMPLEX.")
  (object-not-weak-pointer
   "Object is not a WEAK-POINTER.")
  (object-not-structure
   "Object is not a STRUCTURE.")
  (object-not-base-char
   "Object is not of type BASE-CHAR.")
  (nil-function-returned
   "Function with declared result type NIL returned."))